home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 04 - 1988 / 04.08 Aug 88 / Forth Stuff / ObjectFORTH.9 Edit file next >
Encoding:
Text File  |  1988-06-17  |  15.4 KB  |  756 lines  |  [TEXT/EDIT]
  1. \ ObjectFORTH.9  by
  2.  
  3. \     Wayne Joerding
  4. \    S.E. 430 Dilke St.
  5. \    Pullman, WA 99163
  6.  
  7. \ Copywrite 1988 by Wayne Joerding for MacTutor
  8.  
  9. only mac 
  10. also forth
  11.  
  12.  
  13. $4EBA CONSTANT JSR_d(PC)
  14. $4E75 CONSTANT RTS
  15.  
  16. $203C         Constant  MOVE.L_#,D0
  17. $41FB08FA     Constant  LEA_$-6(PC,D0.L),A0
  18. $2D08        Constant  MOVE.L_A0,-(A6)
  19.  
  20. : Defer.Not.Init ." Uninitialized" abort ;
  21. : Defer 
  22.     Create -4 ALLOT JSR_d(PC) W, 
  23.     ['] Defer.Not.Init HERE - W, RTS W,
  24.     ;
  25. : Let: ( -- cfa+2 )  ' 2 + ;
  26. : Do: ( cfa -- )  ' over - swap W! ;
  27.  
  28. \ ==== ObjectFORTH =======================
  29.  
  30. 20 4 *     CONSTANT Maxnest        
  31. VARIABLE Ostack 
  32.  
  33. \ ---- Allocate space for Object Stack ---
  34. Ostack 4 + maxnest + Ostack ! maxnest Vallot    
  35.  
  36. GLOBAL
  37. : Init.Ostack Ostack 4 + maxnest + Ostack ! ;
  38.  
  39. \ ============================================
  40. CREATE ObjectFORTH    
  41.  
  42. \ ------ Section defining words --------------
  43. GLOBAL Defer :Class
  44. GLOBAL Defer :Instance
  45. GLOBAL Defer ;Class
  46. GLOBAL Defer ;Instance
  47. GLOBAL Defer Hide
  48.  
  49. CREATE Ob.DefWords    
  50. \ ============================================
  51. GLOBAL
  52. CODE DictBase@    ( -- n )    
  53.     MOVE.L $-532(A5),-(A6)     RTS
  54.     END-CODE    MACH
  55.  
  56. : Relink.DefWords
  57.     [ ' Ob.DefWords body>link dup @ swap 
  58.     DictBase@ - swap ] literal literal DictBase@ + !
  59.     ; 
  60. : Delink.DefWords
  61.     [ ' Ob.DefWords body>link ' ObjectFORTH 
  62.     body>link over swap - swap DictBase@ - swap ] 
  63.     literal literal DictBase@ + ! 
  64.     ;
  65.  
  66.  
  67. \ ==== Global Variables for Class Definition ===
  68. VARIABLE #class.Size        
  69. VARIABLE #ins.Size            
  70. VARIABLE #Forth.Head        
  71. VARIABLE #c.Head            
  72. VARIABLE #c.Pub.Tail        
  73. VARIABLE #c.Pvt.Tail        
  74. VARIABLE #i.Head            
  75. VARIABLE #i.Pub.Tail        
  76. VARIABLE #i.Pvt.Tail        
  77. VARIABLE #parent            
  78. VARIABLE #C.or.I?            
  79.  
  80. \ ====== Object stack ===========================
  81. GLOBAL
  82. : Opush  ( n -- )    \ push from Pstack to Ostack
  83.     Ostack dup @ 4 - = 
  84.     IF ." Ostack overflow" abort THEN            
  85.     Ostack -4 over +! @ ! 
  86.     ;
  87.  
  88. GLOBAL
  89. : Opop ( -- )    \ discard top number on Ostack.
  90.     Ostack dup maxnest + 4 + swap @ = 
  91.     IF ." Ostack underflow" abort THEN 
  92.     4 Ostack +! 
  93.     ;
  94.  
  95. GLOBAL
  96. : Ocop+ ( n -- n+os )    \ add Ostack to Pstack.
  97.     Ostack @ @ + 
  98.     ; 
  99.  
  100. GLOBAL
  101. : Ocop ( -- os )    \ copy Ostack to Pstack.
  102.     Ostack @ @ 
  103.     ;
  104.  
  105.  
  106. \ ==== Data Structure Defining Words =============
  107. GLOBAL VARIABLE Offset         
  108.  
  109. GLOBAL
  110. : Ins.Array ( size -- ) ( name -IN- )    
  111. \ Make a new instance variable of 'size' bytes.
  112.     CREATE     immediate    
  113.     Offset @ ,            \ store offset
  114.     dup 2 mod +         \ make sure even number    
  115.     Offset +!            \ increase offset 
  116.     DOES>            ( ob.DFA -OS- ob.DFA )     
  117.         @ [compile] literal    
  118.         compile Ocop+        
  119.     ;
  120.  
  121. GLOBAL
  122. : I.Var ( -- ) ( name -IN- )    
  123.     4 Ins.Array 
  124.     ;
  125.  
  126. GLOBAL
  127. : I.Pntr ( -- ) ( name -IN- )    
  128. \ Make ivar without incrementing.
  129.     CREATE     immediate    
  130.     offset @ ,            \ compile offset.
  131.     DOES>            ( ob.DFA -OS- ob.DFA ) 
  132.         @ [compile] literal    
  133.         compile Ocop+        
  134.     ;    
  135.  
  136. \ ==== Method defining word =======================
  137. GLOBAL
  138. : :M    ( -- )    \ Define a method.
  139.     :
  140.     ;
  141.  
  142.  
  143. \ ====== Custom Abort routine =====================
  144. 80 USER (ABORT)
  145. VARIABLE ^ABORT
  146. : Ob.Abort ( n -- )    \ Use during class definition.
  147.     #C.or.I? @ cr 
  148.     IF ." Class part" ;Class 
  149.     ELSE ." Instance part" ;Instance 
  150.     THEN 
  151.         ^ABORT @ (ABORT) ! ABORT    
  152.     ;
  153.  
  154. \ ====== Message support ===========================
  155. : link>name 4 + ;
  156.  
  157. : Compile.Meth    ( meth.CFA  ob.DFA -- )    
  158. \
  159. \    the following line was edited out -- JL    
  160. \    [compile] literal    \ make a literal of ob.DFA
  161. \
  162. \    and replaced by the following four lines
  163.     MOVE.L_#,D0     W,
  164.     here -           ,
  165.     LEA_$-6(PC,D0.L),A0  ,
  166.      MOVE.L_A0,-(A6)     W,
  167.  
  168.     compile Opush         \ compile a call to opush
  169.     JSR_d(PC) W, here - W,    
  170.     compile Opop
  171.     ;
  172.  
  173. : Do.Meth    ( meth.CFA  ob.DFA -- )
  174.     Opush execute Opop        
  175.     ;
  176.  
  177. : Do.OR.Compile    ( ob.DFA  meth.CFA  f<>0 -- )
  178.     1 =
  179.     IF swap Do.Meth
  180.     ELSE 
  181.         swap state @ 
  182.         IF Compile.Meth
  183.         ELSE Do.Meth    THEN
  184.     THEN
  185.     ;
  186.  
  187. GLOBAL
  188. : Find.Meth?    
  189. { lfa  strng.adr | f -- strng.adr  CFA  f<>0 }
  190. \ f = as with FIND
  191.     0 -> f                                        
  192.     BEGIN
  193.         lfa  link>name C@ %11111 and            
  194.         strng.adr C@ =                             
  195.         IF 1 -> f strng.adr C@ L_ext 1+ 1         
  196.             DO     strng.adr I + C@ lfa 4 + I + C@ <>
  197.                 IF 0 -> f leave THEN
  198.             LOOP
  199.         THEN
  200.         f 0= lfa @ 0 <> and
  201.     WHILE    \ continue if meth <> message & LFA<>0
  202.         lfa  @  negate +> lfa
  203.     REPEAT
  204.     strng.adr f 
  205.     IF lfa dup link>body swap link>name C@
  206.         %10000000 and 
  207.         IF 1 ELSE -1 THEN
  208.     ELSE f
  209.     THEN
  210.     ;
  211.  
  212. GLOBAL
  213. : Get.Meth    ( key  strng.adr -- meth.CFA f<>0 )
  214.     Find.Meth?    
  215.     ?dup IF    
  216.         rot drop         
  217.     ELSE    
  218.         cr ." Method --> " count %11111 and 
  219.         type 3 spaces ." Not Found" ABORT 
  220.     THEN
  221.     ;
  222.  
  223. GLOBAL
  224. : Get.Msg    ( -- strng.adr )
  225.     32 word pad over C@ L_ext 1+ cmove pad
  226.     ;
  227.  
  228. GLOBAL
  229. : Selector ( ob.DFA key -- )    ( <msg> -IN- )
  230.     Get.Msg                
  231.     Get.Meth              
  232.     Do.OR.Compile    
  233.     ;
  234.  
  235.  
  236. CREATE Ob.Words
  237.  
  238. \ ==== Define OBJECT ============================
  239. : :Root
  240.     Create             \ stopper word
  241.     NP @ DictBase@ - ,    
  242.     0 NP @ !            \ put 0 for class.Key
  243.     4 NP +!                \ increment NP by 4 bytes
  244.     ;
  245.  
  246. :Root <root>
  247.  
  248. \ ---- Define class section of OBJECT -----------
  249. here #c.Pvt.Tail !    
  250.  
  251. 0 offset !    
  252. GLOBAL    I.Var class.Key            
  253.         I.Var class.Tail        
  254.         I.Var c.Tail.link        
  255. GLOBAL    I.Var class.Size        
  256. GLOBAL    I.Var ins.Key            
  257.         I.Var ins.Tail            
  258.         I.Var i.Tail.link        
  259. GLOBAL    I.Var ins.Size            
  260.         I.Var parent            
  261.         I.Var Ob.name.link        
  262.         I.Var Class.RLA            
  263. offset @ #class.Size !    
  264.  
  265. : cr5sp cr 5 spaces ;
  266.  
  267. : <Pr.Meth>    ( adr cnt -- )
  268.     cr5sp %11111 and swap over type 
  269.     25 swap - spaces ." Link adr = " 
  270.     dup . space ." Offset = " dup @ .    
  271.     ;
  272.  
  273. : Pr.meths    ( key -- )
  274.     BEGIN                
  275.         dup @                
  276.     WHILE
  277.         dup link>name count    
  278.         <Pr.Meth> dup @  -            
  279.     REPEAT drop 
  280.     ;
  281. CODE ClassStrucAllot    ( n -- addr )
  282.     MOVE.L    $-1FC(A5),D0
  283.     MOVE.L    D0,D1
  284.     ASR.L    #$1,D1
  285.     BCC.S    @1
  286.     ADDQ.L    #$1,D0            
  287. @1    MOVE.L    D0,A0
  288.     ADD.L    (A6)+,D0        
  289.     MOVE.L    D0,$-1FC(A5)    
  290.     MOVE.L    A0,-(A6)        
  291.     MOVE.L    #0,-(A6)        
  292.     RTS
  293.     END-CODE
  294.  
  295.  
  296. : SetClassStruc    ( -- )    
  297.     #class.Size @  ClassStrucAllot    
  298.     IF ." Memory error" . ." Handle" . abort
  299.     ELSE
  300.         dup DictBase@ -  ,                
  301.         Opush                                                        
  302.         #c.Head @ DictBase@ - 
  303.                 class.Key !                
  304.         #c.Pub.Tail    @ dup IF DictBase@ - THEN
  305.                 class.Tail    !                                        
  306.         #c.Pub.Tail @ dup                 
  307.             IF dup #c.Pvt.Tail @ =        
  308.                 IF #Forth.Head @ -         
  309.                 ELSE @ THEN             
  310.             THEN c.Tail.link         !
  311.         #class.Size @ class.Size     !    
  312.         #i.Head @ DictBase@ - 
  313.                 ins.Key !                
  314.         #i.Pub.Tail    @ dup IF DictBase@ - THEN
  315.                 ins.Tail    !            
  316.         #i.Pub.Tail @ dup                 
  317.             IF dup #i.Pvt.Tail @ =        
  318.                 IF #Forth.Head @ -         
  319.                 ELSE @ THEN             
  320.             THEN i.Tail.link         !
  321.         #ins.Size      @ ins.Size     !    
  322.         #parent    @ Parent            !    
  323.         last DictBase@ - Class.RLA     !     
  324.         last @ ob.name.link            !    
  325.         Opop                        
  326.     THEN
  327.     ; 
  328.  
  329. here #c.Pub.Tail !    
  330.  
  331. :M pr.ob.ivar    ( -- )
  332.     cr cr ." Class instance variables are :"
  333.     cr5sp ." class.Key     = " 
  334.         class.Key @ DictBase@ + .    
  335.     cr5sp ." class.Tail    = " 
  336.         class.Tail @ DictBase@ + .
  337.     cr5sp ." c.Tail.link   = " 
  338.         c.Tail.link @ .
  339.     cr5sp ." class.Size    = " 
  340.         class.Size @ .
  341.     cr5sp ." ins.Key       = " 
  342.         ins.Key @ DictBase@ + .
  343.     cr5sp ." ins.Tail      = " 
  344.         ins.Tail @ DictBase@ + .
  345.     cr5sp ." i.Tail.link   = " 
  346.         i.Tail.link @ .
  347.     cr5sp ." ins.Size      = " 
  348.         ins.Size @ .
  349.     cr5sp ." Parent        = " 
  350.         Parent @ DictBase@ + .
  351.     cr5sp ." ob.name.link  = " 
  352.         ob.name.link @ .
  353.     cr5sp ." Class.RLA     = " 
  354.         Class.RLA @ DictBase@ + .
  355.     ;
  356. GLOBAL
  357. :M Pr.class.meths    ( -- )    
  358.     cr cr ." Class methods are :" 
  359.     class.Key @ DictBase@ +            
  360.     Pr.meths
  361.     ;
  362. GLOBAL
  363. :M Pr.ins.meths    ( -- )
  364.     cr cr ." Instance methods are :"
  365.     ins.Key @ DictBase@ +             
  366.     Pr.meths
  367.     ;
  368.  
  369. GLOBAL
  370. :M Describe    ( -- )
  371.     cr ." ---- Class Information ---------------------------------------"
  372.     cr ." NAME : " Class.RLA @ DictBase@ + dup . 
  373.     link>name count %11111 and type 
  374.     5 spaces ." pointer to class data = " Ocop .
  375.     Pr.ob.ivar
  376.     Pr.class.meths
  377.     Pr.ins.meths    cr
  378.     ; 
  379.  
  380. GLOBAL
  381. :M Define.Child.Class    ( -- )    
  382.     last #Forth.Head !            
  383.     class.Size @ #class.Size !    
  384.     ins.Size @ #ins.Size !            
  385.     class.Key @ DictBase@ + #c.Head ! 
  386.     0 #c.Pvt.Tail !                
  387.     0 #c.Pub.Tail !            
  388.     ins.Key @ DictBase@ + #i.Head !
  389.     0 #i.Pvt.Tail !            
  390.     0 #i.Pub.Tail !                
  391.     Ocop DictBase@ - #parent !
  392.     Relink.DefWords    
  393.     [ ' Ob.Abort body>link DictBase@ - ] literal
  394.         DictBase@ + link>body (ABORT) dup @ ^ABORT !  !
  395.  
  396.     ;
  397.  
  398. GLOBAL
  399. :M Name.Child.Class    ( -- )    ( <name> -IN- )
  400.     Delink.DefWords                        
  401.     ^ABORT @ (ABORT) !     \ restore old abort routine
  402.     CREATE immediate                    
  403.     SetCLassStruc
  404.  
  405.     \ -- seal class and link to parent ------------
  406.     last dup #Forth.Head @ - swap    !        
  407.     #c.Pub.Tail @ ?dup     \ false => no class section
  408.         IF  #c.Pvt.Tail @ dup #Forth.Head @ - swap  !
  409.             dup class.Key @ DictBase@ + - swap  !
  410.         THEN                     
  411.     #i.Pub.Tail @ ?dup     \ false => no class section
  412.         IF     #i.Pvt.Tail @ dup #Forth.Head @ - swap !
  413.             dup ins.Key @ DictBase@ + - swap !
  414.         THEN                     
  415.  
  416.     DOES> @ DictBase@ + dup @ DictBase@ + Selector
  417.     ;
  418. GLOBAL
  419. :M Make.Instance    ( -- )    ( <name> -IN- )
  420.     CREATE immediate        
  421.     ins.Key @ ,            
  422.     ins.Size @ allot
  423.     DOES> dup @ DictBase@ + Selector
  424.     ;
  425.  
  426. last #c.Head !
  427.  
  428.  
  429. \ -----Define instance section of root object ---------
  430.  
  431. here #i.Pvt.Tail !
  432.  
  433. 0 Offset !
  434.     
  435. GLOBAL    I.Var I.Key    
  436.  
  437. Offset @ #ins.Size !
  438. here #i.Pub.Tail !    
  439.  
  440. GLOBAL
  441. :M Pr.Imeths    ( -- )
  442.     I.Key @ DictBase@ +    
  443.     cr cr ." Instance methods are :"
  444.     Pr.meths
  445.     ;
  446. GLOBAL
  447. :M Name    ( -- )
  448.     cr ." NAME : " Ocop 4 - body>link link>name count 
  449.     %11111 and type 5 spaces ." instance.DFA = " I.Key . 
  450.     ;
  451. GLOBAL
  452. :M Describe ( -- )
  453.     cr ." ---- Instance information ------------------------------------"
  454.     Name
  455.     Pr.Imeths
  456.     ;
  457.  
  458. last #i.Head !
  459.  
  460.  
  461. \ ---- Child Class defining words ------------------
  462. : Relink    { t o k | -- } ( dfa -OS- dfa' )
  463.         Class.RLA @ dup DictBase@ + 
  464.         dup @ Ob.name.link  ! 
  465.         swap k @ - swap  ! 
  466.         o @ t @ DictBase@ + dup @ o  ! !
  467.     ;
  468.  
  469. : Relink.Parents    ( -- )
  470.     #parent @ DictBase@ + Opush 
  471.     #C.or.I? @ 
  472.     IF
  473.         Begin
  474.             class.Key @
  475.         While
  476.             class.Tail dup @
  477.             IF         c.Tail.link  class.Key 
  478.                     Relink
  479.             ELSE    drop
  480.             THEN    Parent @ DictBase@ +
  481.                     Opop Opush
  482.         Repeat
  483.     ELSE
  484.         Begin
  485.             class.Key @
  486.         While
  487.             ins.Tail dup @
  488.             IF         i.Tail.link  ins.Key 
  489.                     Relink
  490.             ELSE    drop
  491.             THEN    Parent @ DictBase@ +
  492.                     Opop Opush
  493.         Repeat
  494.     THEN
  495.     Opop 
  496.     ;
  497.  
  498. : Delink    { o t | -- } ( dfa -OS- dfa' )
  499.     t @    
  500.     IF
  501.         Ob.name.link @ Class.RLA @ DictBase@ + !
  502.         o @ t @ DictBase@ + dup @ o ! !
  503.     THEN
  504.         Parent @ DictBase@ + 
  505.         Opop Opush
  506.     ;
  507.  
  508. : Delink.Parents ( -- )
  509.     #parent @ DictBase@ + Opush 
  510.     #C.or.I? @             
  511.     IF
  512.         Begin
  513.             class.Key @    \ class.Key is zero for <root>
  514.         While
  515.             c.Tail.link   class.Tail
  516.             Delink
  517.         Repeat
  518.     ELSE
  519.         Begin
  520.             class.Key @    \ class.Key is zero for <root>
  521.         While
  522.             i.Tail.link   ins.Tail 
  523.             Delink
  524.         Repeat
  525.     THEN
  526.     Opop
  527.     ;
  528.  
  529. : <:Class>    ( -- )
  530.     #class.Size @ Offset !
  531.     here #c.Pvt.Tail !    
  532.     here #c.Pub.Tail !
  533.     -1 #C.or.I? !
  534.     Relink.Parents    
  535.     ;
  536. Let: :Class Do: <:Class>
  537.  
  538. : <;Class>    ( -- )
  539.     last #c.Head !
  540.     Offset @ #class.Size !
  541.     #c.Pvt.Tail @ body>link #c.Pvt.Tail !
  542.     #c.Pub.Tail @ body>link #c.Pub.Tail !
  543.     Delink.Parents
  544.     ;
  545. Let: ;Class Do: <;Class>
  546.  
  547. : <:Instance>    ( -- )
  548.     #ins.Size @ Offset !
  549.     here #i.Pvt.Tail !
  550.     here #i.Pub.Tail !
  551.     0 #C.or.I? !
  552.     Relink.Parents
  553.     ;
  554. Let: :Instance Do: <:Instance>
  555.  
  556. : <;Instance>    ( -- )
  557.     last #i.Head !
  558.     Offset @ #ins.Size !
  559.     #i.Pvt.Tail @ body>link #i.Pvt.Tail !
  560.     #i.Pub.Tail @ body>link #i.Pub.Tail !
  561.     Delink.Parents
  562.     ;
  563. Let: ;Instance Do: <;Instance>
  564.  
  565. : <Hide>
  566.     here #C.or.I? @ 
  567.     IF  #c.Pub.Tail ! ELSE  #i.Pub.Tail ! THEN
  568.     ;
  569.  
  570. Let: Hide Do: <Hide>
  571.  
  572. \ ------ Complete and Seal root object -----------
  573.  
  574. : :OBJECT
  575.     CREATE immediate    \ make header for "OBJECT"
  576.     DOES> @ DictBase@ + dup @ DictBase@ + Selector
  577.     ;
  578.  
  579. :OBJECT OBJECT
  580.  
  581. \ -- Initialize temporary variables used by Set.Struc --
  582.     ' <root> 4 + @ #parent !                
  583.     ' Ob.Words body>link #Forth.Head !
  584.     #c.Pub.Tail @ body>link #c.Pub.Tail !    
  585.     #i.Pub.Tail @ body>link #i.Pub.Tail !    
  586.     #c.Pvt.Tail @ body>link #c.Pvt.Tail !    
  587.     #i.Pvt.Tail @ body>link #i.Pvt.Tail !    
  588.     
  589. SetClassStruc            \ init class data structure 
  590.  
  591. \ -- seal class and link to <root> -----------------
  592.     Delink.DefWords
  593.     ' <root> body>link #parent !            
  594.     #i.Pub.Tail @ dup #parent @ - swap !
  595.     #c.Pub.Tail @ dup #parent @ - swap !
  596.     #i.Pvt.Tail @ dup #Forth.Head @ - swap !
  597.     #c.Pvt.Tail @ dup #Forth.Head @ - swap !
  598.     0 ' <root> body>link 
  599.     last dup ' Ob.DefWords body>link - swap
  600.     !    !    
  601.  
  602. \ ====== EXAMPLES ==================
  603. \ ====== Integer Class =============
  604.  OBJECT Define.Child.Class
  605.     :Instance
  606.         I.Var Int
  607.     Hide
  608.         :M Fetch ( -- n )
  609.             Int @
  610.             ;
  611.         :M Save ( n -- )
  612.             Int ! 
  613.             ;
  614.     ;Instance
  615.  
  616. OBJECT    Name.Child.Class             Integer
  617.  
  618.  
  619. \ ====== 10 cell Array Class ==============
  620. OBJECT Define.Child.Class
  621. :Instance
  622.     10 Constant            Max.Size     
  623.     10 4 * Ins.Array    Head
  624. Hide
  625.     :M Describe
  626.         cr ." ---- Instance Information ---------------------------------"
  627.         Name
  628.         cr ." Max.Size (in cells)  = " Max.Size .
  629.         Pr.Imeths
  630.         ;
  631.     :M Store ( x i -- )
  632.     \ Store value x in array for index = i
  633.         Max.Size over 1 + < if ." index out of bounds" abort then
  634.         4 * Head + !                                                
  635.         ;
  636.     :M Retrieve ( i -- )
  637.     \ Retrieve value of array for index = i.
  638.         Max.Size over 1 + < if ." index out of bounds" abort then
  639.         4 * Head + @                                                
  640.         ;
  641. ;Instance
  642. OBJECT    Name.Child.Class            Array10    ( -- )
  643.  
  644.  
  645. \ ====== Variable size Array Class ===============
  646. Integer Define.Child.Class
  647. :Instance
  648.     I.Var    Max.Index    \ max size of array
  649.     I.Var    Length         \ number of elements in array
  650.     I.Pntr    Start        \ points to the start of array memory
  651. Hide
  652.     :M Describe
  653.         cr ." ---- Instance Information ---------------------------------"
  654.         Name
  655.         cr ." Max Length in cells  = " Max.Index @ 1+ .
  656.         cr ." Cell size in bytes   = " Int @ .
  657.         Pr.Imeths
  658.         ;
  659.     :M Store ( x i -- )    \ Store value x in array for index = i, first cell has index of zero
  660.         Max.Index @ over < over 0 < or IF ." index out of bounds" abort THEN \ <-- error checking
  661.         Int @ * Start + !                                                
  662.         ;
  663.     :M Retrieve ( i -- )    \ Retrieve value of array for index = i.
  664.         Max.Index @ over < over 0 < or IF ." index out of bounds" abort THEN \ <-- error checking
  665.         Int @  * Start + @                                                
  666.         ;
  667. ;Instance
  668. :Class
  669.     :M Make.Instance ( n c -- ) ( <name> -IN- ) 
  670.     \ Array instance of size n cells, cell size of c
  671.         CREATE immediate
  672.         ins.Key @             
  673.         ,                    \ store key to methods of parent class
  674.         dup ,                \ save cell size in 'Int' variable
  675.         over 1-  ,             \ make and save Max.Index
  676.         0 ,                    \ init current Length to zero
  677.         * ins.Size @ + allot    
  678.         DOES> dup @ DictBase@ + Selector
  679.         ;
  680. ;Class
  681. Integer    Name.Child.Class            Array    ( n c -- )
  682.  
  683.  
  684. \ ====== Vector Class ================================
  685. Array Define.Child.Class
  686.     :Class
  687.         :M Make.Instance ( n -- )
  688.             4 Make.Instance
  689.             ;
  690.     ;Class
  691. Array Name.Child.Class                Vector ( n -- )
  692.  
  693.  
  694. \ ====== String Class =================================
  695. Array     Define.Child.Class
  696. :Class
  697.     :M Make.Instance ( n -- )
  698.         1 Make.Instance
  699.         ;
  700. ;Class
  701. :Instance
  702.     :M Describe
  703.         cr ." ---- Instance Information ---------------------------------"
  704.         Name
  705.         cr 5 spaces ." Max String length        = " Max.Index @ 1+ .
  706.         cr 5 spaces ." Current String length    = " Length @ .
  707.         Pr.Imeths
  708.         ;
  709.     :M Print ( -- )    \ Prints string for this instance.
  710.         Start Length @  dup IF type ELSE ." string empty" drop drop THEN
  711.         ;
  712.     :M Store ( a -- )    \ Store a string with count byte at address.
  713.         count dup Max.Index @ 2 + <
  714.         IF dup Length ! Start swap cmove
  715.         ELSE cr ." String too large for 'Store' " drop drop
  716.         THEN
  717.         ;
  718. ;Instance
  719. Array    Name.Child.Class            String    ( n -- ) 
  720.  
  721.  
  722. \ ==== Struc Class =================================
  723. OBJECT Define.Child.Class    
  724. :Class
  725.     : Make.Instance ( -- ) ( name -IN- )
  726.         CREATE immediate
  727.         Ins.Key @ ,
  728.         ins.Size @ allot
  729.         DOES> dup @ DictBase@ + Get.Msg Get.Meth
  730.             drop execute state @    
  731.             IF [compile] literal THEN
  732.         ;
  733. ;Class
  734. :Instance
  735.     : S.Array ( size -- ) ( name -IN- )
  736.         CREATE                 
  737.         offset @ ,            
  738.         dup 2 mod +         
  739.         offset +!    
  740.         DOES> @  +
  741.         ;
  742.     : LongInt ( -- ) ( name -IN- )
  743.         4 S.Array
  744.         ;
  745. ;Instance
  746. OBJECT    Name.Child.Class            Struct
  747.  
  748. \ ==== Point Class ========================
  749. Struct Define.Child.Class    
  750.     :Instance
  751.         LongInt Xdim
  752.         LongInt Ydim
  753.     ;Instance
  754. Struct    Name.Child.Class             Point
  755.  
  756.